home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / apel / filename.el.z / filename.el
Encoding:
Text File  |  1998-05-21  |  4.2 KB  |  163 lines
  1. ;;; filename.el --- file name filter
  2.  
  3. ;; Copyright (C) 1996,1997 MORIOKA Tomohiko
  4.  
  5. ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  6. ;; Version: $Id: filename.el,v 2.1 1997/11/06 15:50:53 morioka Exp $
  7. ;; Keywords: file name, string
  8.  
  9. ;; This file is part of APEL (A Portable Emacs Library).
  10.  
  11. ;; This program is free software; you can redistribute it and/or
  12. ;; modify it under the terms of the GNU General Public License as
  13. ;; published by the Free Software Foundation; either version 2, or (at
  14. ;; your option) any later version.
  15.  
  16. ;; This program is distributed in the hope that it will be useful, but
  17. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19. ;; General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Code:
  27.  
  28. (require 'emu)
  29. (require 'cl)
  30.  
  31. (defsubst poly-funcall (functions argument)
  32.   "Apply initial ARGUMENT to sequence of FUNCTIONS.
  33. FUNCTIONS is list of functions.
  34.  
  35. (poly-funcall '(f1 f2 .. fn) arg) is as same as
  36. (fn .. (f2 (f1 arg)) ..).
  37.  
  38. For example, (poly-funcall '(car number-to-string) '(100)) returns
  39. \"100\"."
  40.   (while functions
  41.     (setq argument (funcall (car functions) argument)
  42.       functions (cdr functions))
  43.     )
  44.   argument)
  45.  
  46.  
  47. ;;; @ variables
  48. ;;;
  49.  
  50. (defvar filename-limit-length 21 "Limit size of file-name.")
  51.  
  52. (defvar filename-replacement-alist
  53.   '(((?\  ?\t) . "_")
  54.     ((?! ?\" ?# ?$ ?% ?& ?' ?\( ?\) ?* ?/
  55.      ?: ?\; ?< ?> ?? ?\[ ?\\ ?\] ?` ?{ ?| ?}) . "_")
  56.     (filename-control-p . "")
  57.     )
  58.   "Alist list of characters vs. string as replacement.
  59. List of characters represents characters not allowed as file-name.")
  60.  
  61. (defvar filename-filters
  62.   (let ((filters '(filename-special-filter
  63.            filename-eliminate-top-low-lines
  64.            filename-canonicalize-low-lines
  65.            filename-maybe-truncate-by-size
  66.            filename-eliminate-bottom-low-lines
  67.            )))
  68.     (require 'path-util)
  69.     (if (exec-installed-p "kakasi")
  70.     (cons 'filename-japanese-to-roman-string filters)
  71.       filters))
  72.   "List of functions for file-name filter.")
  73.  
  74.  
  75. ;;; @ filters
  76. ;;;
  77.  
  78. (defun filename-japanese-to-roman-string (str)
  79.   (save-excursion
  80.     (set-buffer (get-buffer-create " *temp kakasi*"))
  81.     (erase-buffer)
  82.     (insert str)
  83.     (call-process-region (point-min)(point-max) "kakasi" t t t
  84.              "-Ha" "-Ka" "-Ja" "-Ea" "-ka")
  85.     (buffer-string)
  86.     ))
  87.  
  88. (defun filename-control-p (character)
  89.   (let ((code (char-int character)))
  90.     (or (< code 32)(= code 127))
  91.     ))
  92.  
  93. (defun filename-special-filter (string)
  94.   (let (dest
  95.     (i 0)
  96.     (len (length string))
  97.     (b 0)
  98.     )
  99.     (while (< i len)
  100.       (let* ((chr (sref string i))
  101.          (ret (assoc-if (function
  102.                  (lambda (key)
  103.                    (if (functionp key)
  104.                    (funcall key chr)
  105.                  (memq chr key)
  106.                  )))
  107.                 filename-replacement-alist))
  108.          )
  109.     (if ret
  110.         (setq dest (concat dest (substring string b i)(cdr ret))
  111.           i (+ i (char-length chr))
  112.           b i)
  113.       (setq i (+ i (char-length chr)))
  114.       )))
  115.     (concat dest (substring string b))
  116.     ))
  117.  
  118. (defun filename-eliminate-top-low-lines (string)
  119.   (if (string-match "^_+" string)
  120.       (substring string (match-end 0))
  121.     string))
  122.  
  123. (defun filename-canonicalize-low-lines (string)
  124.   (let (dest)
  125.     (while (string-match "__+" string)
  126.       (setq dest (concat dest (substring string 0 (1+ (match-beginning 0)))))
  127.       (setq string (substring string (match-end 0)))
  128.       )
  129.     (concat dest string)
  130.     ))
  131.  
  132. (defun filename-maybe-truncate-by-size (string)
  133.   (if (and (> (length string) filename-limit-length)
  134.        (string-match "_" string filename-limit-length)
  135.        )
  136.       (substring string 0 (match-beginning 0))
  137.     string))
  138.  
  139. (defun filename-eliminate-bottom-low-lines (string)
  140.   (if (string-match "_+$" string)
  141.       (substring string 0 (match-beginning 0))
  142.     string))
  143.  
  144.  
  145. ;;; @ interface
  146. ;;;
  147.  
  148. (defun replace-as-filename (string)
  149.   "Return safety filename from STRING.
  150. It refers variable `filename-filters' and default filters refers
  151. `filename-limit-length', `filename-replacement-alist'."
  152.   (and string
  153.        (poly-funcall filename-filters string)
  154.        ))
  155.  
  156.  
  157. ;;; @ end
  158. ;;;
  159.  
  160. (provide 'filename)
  161.  
  162. ;;; filename.el ends here
  163.